;;;;;; null-syntax.scm - Core Scheme Syntax Macros.    -*- Mode: Scheme -*-
;;;;;; Author: Erik Silkensen <silkense@colorado.edu>
;;;;;; Version: 19 Sep 2009

;;; This file defines core macros for the Scheme language. It is loaded
;;; and processed by the syntax expander to define the ``null-prog''
;;; before a program is expanded.

(define-syntax define
  (syntax-rules ()
    ((_ (var . args) . body)
     (define var (lambda args . body)))
    ((_ var init) (_define var init))))

(define-syntax let
  (syntax-rules ()
    ((_ ((var init) ...) . body)
     ((lambda (var ...) . body)
      init ...))
    ((_ name ((var init) ...) . body)
     ((letrec ((name (lambda (var ...) . body)))
        name)
      init ...))))

(define-syntax let*
  (syntax-rules ()
    ((_ () . body)
     (let () . body))
    ((_ ((var init) . bindings) . body)
     (let ((var init))
       (let* bindings . body)))))

(define-syntax letrec
  (syntax-rules ()
    ((_ ((var init) ...) . body)
     (let ((var #f) ...)     ; TODO: this isn't correct: all inits must
       (set! var init) ...   ; be eval'd and stored in fresh locs before
       (let () . body)))))   ; they are assigned to the var locs

(define-syntax cond
  (syntax-rules (else =>)
    ((_) (if #f #f))
    ((_ (else . exps)) (begin . exps))
    ((_ (x) . rest) (or x (cond . rest)))
    ((_ (x => proc) . rest)
     (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
    ((_ (x . exps) . rest)
     (if x (begin . exps) (cond . rest)))))

(define-syntax and
  (syntax-rules ()
    ((_) #t)
    ((_ test) test)
    ((_ test . tests) (if test (and . tests) #f))))

(define-syntax or
  (syntax-rules ()
    ((_) #f)
    ((_ test) test)
    ((_ test . tests) (let ((x test)) (if x x (or . tests))))))

(define-syntax do
  (syntax-rules ()
    ((_ ((var init step) ...)
        (test expression ...)
        command ...)
     (let loop ((var init) ...)
       (if test
           (begin expression ...)
           (begin command ...
                  (loop step ...)))))))

(define-syntax delay
  (syntax-rules ()
    ((_ exp)
     (let ((mem #f) (val #f))
       (lambda ()
         (if mem
             val
             (begin (set! mem #t)
                    (set! val (begin exp))
                    val)))))))

(define-syntax quasiquote 
  (syntax-rules (unquote unquote-splicing quasiquote) 
    ((_ (unquote form)) 
     form) 
    ((_ ((unquote-splicing form) . rest)) 
     (append form (quasiquote rest))) 
    ((_ (quasiquote form) . depth) 
     (list 'quasiquote (quasiquote form #f . depth))) 
    ((_ (unquote form)  x . depth) 
     (list 'unquote (quasiquote form . depth))) 
    ((_ (unquote-splicing form) x . depth) 
     (list 'unquote-splicing (quasiquote form . depth))) 
    ((_ (car . cdr) . depth) 
     (cons (quasiquote car . depth) (quasiquote cdr . depth))) 
;    ((_ #(elt ...) . depth) 
;     (list->vector (quasiquote (elt ...) . depth))) 
    ((_ atom . depth) 
     'atom)))

(define-syntax aif
  (syntax-rules ()
    ((_ name test true false)
     (let ((name test))
       (if name true false)))
    ((_ name pred test true false)
     (let ((name test))
       (if (pred name) true false)))))
    
